home *** CD-ROM | disk | FTP | other *** search
/ Delphi Magazine Collection 2001 / Delphi Magazine Collection 20001 (2001).iso / DISKS / Issue36 / construc / DRBOBPOP.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1998-06-30  |  4.8 KB  |  181 lines
  1. unit DrBobPOP;
  2. interface
  3. uses
  4.   Classes, ScktComp;
  5.  
  6. type
  7.   TBPOP3 = class(TComponent)
  8.   public
  9.     constructor Create(AOwner: TComponent); override;
  10.     destructor Destroy; override;
  11.   public
  12.     procedure ReadMail;
  13.     procedure DeleteMessage(Nr: Integer);
  14.   protected
  15.     _Socket: TClientSocket;
  16.     Step,Mess: Integer;
  17.     procedure SocketRead(Sender: TObject; Socket: TCustomWinSocket);
  18.     procedure SocketWrite(Sender: TObject; Socket: TCustomWinSocket);
  19.   private
  20.     fMailServer: String;
  21.     fUser: String;
  22.     fPassword: String;
  23.     fMessages: Integer;
  24.   published
  25.     property MailServer: String read fMailServer write fMailServer;
  26.     property User: String read fUser write fUser;
  27.     property Password: String write fPassword;
  28.   protected
  29.     function GetMessage(Index: Integer): String;
  30.   public
  31.     property Messages: Integer read fMessages;
  32.     property Message[Index: Integer]: String read GetMessage;
  33.   private
  34.     LastSocket: TCustomWinSocket;
  35.     fMessage: Array of String;
  36.     Status: String;
  37.   end;
  38.  
  39. implementation
  40. uses
  41.   SysUtils, Forms; { for the Application.ProcessMessages-loop }
  42.  
  43. const
  44.   St_USER = 1;
  45.   St_PASS = 2;
  46.   St_STAT = 3;
  47.   St_RETR = 4;
  48.   St_QUIT = 5;
  49.  
  50. const
  51.   CRLF = #13#10;
  52.  
  53. constructor TBPOP3.Create(AOwner: TComponent);
  54. begin
  55.   inherited Create(AOwner);
  56.   _Socket := TClientSocket.Create(Self);
  57.   _Socket.Port := 110;
  58.   _Socket.OnRead := SocketRead;
  59.   _Socket.OnWrite := SocketWrite;
  60.   LastSocket := nil;
  61.   Step := 0
  62. end {Create};
  63.  
  64. destructor TBPOP3.Destroy;
  65. begin
  66.   _Socket.OnRead := nil;
  67.   Step := St_QUIT;
  68.   if Assigned(LastSocket) then LastSocket.SendText('QUIT'+ CRLF);
  69.   _Socket.Free;
  70.   _Socket := nil;
  71.   fMessage := nil;
  72.   inherited Destroy
  73. end {Destroy};
  74.  
  75. function TBPOP3.GetMessage(Index: Integer): String;
  76. begin
  77.   if Index < Length(fMessage) then Result := fMessage[Index]
  78.                               else Result := ''
  79. end {GetMessage};
  80.  
  81. procedure TBPOP3.DeleteMessage(Nr: Integer);
  82. begin
  83.   Step := St_QUIT;
  84.   if Assigned(LastSocket) then LastSocket.SendText('DELE '+ IntToStr(Nr) + CRLF);
  85.   repeat
  86.   { need to rewrite this using low-level Windows APIs }
  87.     Application.ProcessMessages
  88.   until Step > St_QUIT
  89. end;
  90.  
  91. procedure TBPOP3.SocketRead(Sender: TObject; Socket: TCustomWinSocket);
  92. var
  93.   EOM: Boolean;
  94.   i: Integer;
  95. begin
  96.   LastSocket := Socket; { talk back ? }
  97.   Status := Socket.ReceiveText;
  98.   EOM := Pos(#13#10'.'#13#10,Status) = Length(Status)-4;
  99.   while (Length(Status) > 0) and (Status[Length(Status)] in [#10,#13]) do
  100.     Delete(Status,Length(Status),1);
  101.   case Step of
  102.     0: Step := St_USER;
  103.     St_USER: if Pos('-ERR',Status) > 0 then Step := St_QUIT
  104.                                        else Step := St_PASS;
  105.     St_PASS: if Pos('-ERR',Status) > 0 then Step := St_QUIT
  106.                                        else Step := St_STAT;
  107.     St_STAT:
  108.       if Pos('+OK',Status) = 1 then
  109.       try
  110.         try
  111.           Delete(Status,1,3);
  112.           while Status[1] = #32 do Delete(Status,1,1);
  113.           Delete(Status,Pos(#32,Status),255);
  114.           fMessages := StrToInt(Status);
  115.           Mess := fMessages;
  116.           if fMessages > 0 then
  117.           begin
  118.             SetLength(fMessage,Mess);
  119.             for i:=Pred(fMessages) downto 0 do fMessage[i] := ''
  120.           end
  121.         except
  122.           fMessages := 0
  123.         end
  124.       finally
  125.         if fMessages <= 0 then Step := St_QUIT { Bye, Bye }
  126.         else
  127.         begin
  128.           Status := '+OK'; { retrieve first message }
  129.           Mess := 1;
  130.           Step := St_RETR
  131.         end
  132.       end;
  133.     St_RETR:
  134.       begin
  135.         fMessage[Pred(Mess)] := fMessage[Pred(Mess)] + Status;
  136.         if EOM then
  137.         begin
  138.           Delete(fMessage[Pred(Mess)],1,Pos(#13#10,fMessage[Pred(Mess)])+1);
  139.           Delete(fMessage[Pred(Mess)],Length(fMessage[Pred(Mess)]),1);
  140.           Inc(Mess); { message is done in "Message" }
  141.           Status := '+OK'
  142.         end;
  143.         if Mess > fMessages then Step := St_QUIT
  144.       end;
  145.     St_QUIT:
  146.       Inc(Step)
  147.   end;
  148.   SocketWrite(Sender, Socket)
  149. end {SocketRead};
  150.  
  151. procedure TBPOP3.SocketWrite(Sender: TObject; Socket: TCustomWinSocket);
  152. var
  153.   Send: String;
  154. begin
  155.   Send := 'NOOP';
  156.   case Step of
  157.     St_USER: Send := 'USER ' + fUser;
  158.     St_PASS: Send := 'PASS ' + fPassword;
  159.     St_STAT: Send := 'STAT';
  160.     St_RETR: if Status = '+OK' then
  161.                Send := 'RETR ' + IntToStr(Mess);
  162.     St_QUIT: Send := 'NOOP'; // 'QUIT';
  163.   end;
  164.   if (Step in [St_USER..St_QUIT]) and (Send <> 'NOOP') then
  165.     Socket.SendText(Send + CRLF)
  166. end {SocketWrite};
  167.  
  168. procedure TBPOP3.ReadMail;
  169. begin
  170.   Step := 0;
  171.   _Socket.Active := False;
  172.   _Socket.Host := fMailServer;
  173.   _Socket.Open;
  174.   repeat
  175.   { need to rewrite this using low-level Windows APIs }
  176.     Application.ProcessMessages
  177.   until Step >= St_QUIT
  178. end {ReadMail};
  179.  
  180. end.
  181.